home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 April / CICA MS Windows - April 1993.iso / unzipped / programr / tp / tpwmi2 / memstat.pas < prev    next >
Pascal/Delphi Source File  |  1992-05-11  |  4KB  |  166 lines
  1. program MemStats;
  2.  
  3. {$R MemStat.RES}
  4.  
  5. uses WObjects, WinTypes, WinProcs, Strings, Frames;
  6.  
  7. type
  8.     TMemStatsApp = object(TApplication)
  9.         procedure InitMainWindow; virtual;
  10.     end;
  11.  
  12.     PMemStatsWindow = ^TMemStatsWindow;
  13.     TMemStatsWindow = object(TWindow)
  14.         function GetClassName: PChar; virtual;
  15.         procedure SetupWindow; virtual;
  16.         procedure GetWindowClass(var AWndClass: TWndClass); virtual;
  17.         procedure Paint(PaintDC:HDC; var PaintInfo:TPaintStruct); virtual;
  18.         procedure WMDestroy(var Msg:TMessage); virtual wm_First+wm_Destroy;
  19.         procedure About;
  20.         procedure WMQueryOpen(var Msg:TMessage); virtual wm_First+wm_QueryOpen;
  21.         procedure WMSysCommand(var Msg:TMessage); virtual wm_First+wm_SysCommand;
  22.         procedure WMTimer(var Msg:TMessage); virtual wm_First+wm_Timer;
  23.     end;
  24.  
  25. var
  26.     R:TRect;
  27.     PctTxt:array[0..4] of Char;
  28.     InitMem:longint;
  29.  
  30. const
  31.     sc_About=100;
  32.     sc_Options=101;
  33.  
  34. procedure TMemStatsApp.InitMainWindow;
  35. begin
  36.     MainWindow := New(PMemStatsWindow, Init(nil, 'Memory Stats'));
  37.     InitMem:=MemAvail;
  38. end;
  39.  
  40. function TMemStatsWindow.GetClassName: PChar;
  41. begin
  42.     GetClassName := 'MemStats'
  43. end;
  44.  
  45. procedure TMemStatsWindow.GetWindowClass(var AWndClass: TWndClass);
  46. begin
  47.     TWindow.GetWindowClass(AWndClass);
  48.     AWndClass.HIcon := 0; {This is a necessary line. It tells Windows to
  49.                                                  leave the iconized window blank, allowing a
  50.                                                  program to draw on it.}
  51. end;
  52.  
  53. procedure TMemStatsWindow.SetupWindow;
  54. var ResMenu:HMenu;
  55.         T:longint;
  56. begin
  57.     TWindow.SetupWindow;
  58.     if SetTimer(HWindow,20,500,nil)=0 then  {timer set for 1/2 second}
  59.     begin
  60.         MessageBox(HWindow,'Too many timers in use. Cannot load.',
  61.                              'MemStats Stats',mb_IconExclamation or mb_OK);
  62.         CloseWindow;
  63.     end;
  64.     UpdateWindow(HWindow);
  65.     ResMenu:=GetSystemMenu(HWindow,false);
  66.     DeleteMenu(ResMenu,sc_Restore,mf_ByCommand);
  67.     DeleteMenu(ResMenu,sc_Maximize,mf_ByCommand);
  68.             {This is a weird one - I couldn't gray Restore and Maximize for
  69.              some reason...so I deleted them. Pretty unnecessary. If someone
  70.              could tell me what I'm doing wrong here, could you please tell me?}
  71.     AppendMenu(ResMenu,mf_String,0,nil);
  72.     AppendMenu(ResMenu,mf_String,sc_About,'&About Memory Stats...');
  73.     SendMessage(HWindow,wm_Timer,1,0);
  74. end;
  75.  
  76. procedure TMemStatsWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
  77. var TextMetrics:TTextMetric;
  78.         LogicFont:HFont;
  79.         size:integer;
  80.         wout:boolean;
  81. begin
  82.     with R do
  83.     begin
  84.         Right:=GetSystemMetrics(sm_CXIcon)+3;
  85.         Bottom:=GetSystemMetrics(sm_CYIcon)+3;
  86.         Left:=0;Top:=0;
  87.     end;
  88.     DrawBorderFrame(PaintDC,R,true);
  89.     size:=15;
  90.     wout:=true;
  91.     while wout do
  92.     begin
  93.         LogicFont := CreateFont(size,0,0,0,900,0,0,0,0,0,0,0,ff_Swiss+Variable_Pitch,'MS Sans Serif');
  94.         SelectObject(PaintDC,LogicFont);
  95.         If Loword(GetTextExtent(PaintDC,'100%',4))<(R.right-2) then wout:=false
  96.         else
  97.             begin
  98.                 DeleteObject(LogicFont);
  99.                 size:=size-1;
  100.             end;
  101.     end;
  102.     SetBkMode(PaintDC,Transparent);
  103.     SetTextAlign(PaintDC,ta_Bottom);
  104.     SetTextColor(PaintDC,RGB(0,0,0));
  105.     GetTextMetrics(PaintDC,TextMetrics);
  106.     TextOut(PaintDC,Round((R.right-Loword(GetTextExtent(PaintDC,PctTxt,StrLen(PctTxt))))/2),
  107.         R.bottom-Round((R.bottom-TextMetrics.tmHeight-2)/2),PctTxt,StrLen(PctTxt));
  108.     DeleteObject(LogicFont);
  109. end;
  110.  
  111. procedure TMemStatsWindow.WMTimer(var Msg:TMessage);
  112. var
  113.     wFree,wSize:word;
  114.     GDIPct,UserPct,dwInfo:longint;
  115.     PctTxtT:array[0..4] of char;
  116.     PctNum:string;
  117. begin
  118.     Str(Round(MemAvail/InitMem*100),PctNum);
  119.     StrPCopy(PctTxtT,PctNum+'%');
  120.     if (StrPas(PctTxtT) <> StrPas(PctTxt)) or (Msg.wParam=1) then
  121.     begin
  122.         StrPCopy(PctTxt,PctTxtT);
  123.         InvalidateRect(HWindow,nil,false);
  124.         UpdateWindow(HWindow);
  125.     end;
  126. end;
  127.  
  128. procedure TMemStatsWindow.WMQueryOpen(var Msg:TMessage);
  129. begin
  130.     Msg.Result:=0;
  131. end;
  132.  
  133. procedure TMemStatsWindow.WMDestroy(var Msg:TMessage);
  134. begin
  135.     KillTimer(HWindow,20);
  136.     TWindow.WMDestroy(Msg);
  137. end;
  138.  
  139. procedure TMemStatsWindow.WMSysCommand(var Msg:TMessage);
  140. begin
  141.     case Msg.wParam of
  142.         sc_About:
  143.                 About  {I was thinking about adding an Options... menu item.}
  144.         else             {That's why this unnecessary Case command is here.}
  145.             DefWndProc(Msg);
  146.     end;
  147. end;
  148.  
  149. procedure TMemStatsWindow.About;
  150. var Dialog:TDialog;
  151. begin
  152.     Dialog.Init(@Self, 'About');
  153.     Dialog.Execute;
  154.     Dialog.Done;
  155. end;
  156.  
  157. var
  158.     MemStatsApp: TMemStatsApp;
  159.  
  160. begin
  161.     CmdShow:=sw_Minimize;
  162.     MemStatsApp.Init('MemStatsApp');
  163.     MemStatsApp.Run;
  164.     MemStatsApp.Done;
  165. end.
  166.